package NonmemHandler;

use strict;
use warnings;

use vars qw/$VERSION/;
$VERSION = '1.0000';
use Data::Dumper;

# Define constants for reporting values that are more dissimilar than accepted index
our $ACCEPTED_THETA_DISS;
our $ACCEPTED_SIGMA_DISS;
our $ACCEPTED_OMEGA_DISS;
our $ACCEPTED_MINOBJ_DISS;
our $REPORT_ROGUE;
our $REPORT_MISSING;

sub new {       
    my ($proto, %args) = @_;
    my $class = ref($proto) || $proto;
    my $self  = \%args;
    bless ($self, $class);
    $ACCEPTED_MINOBJ_DISS = $self->{accepted_minobj_diss};
    $ACCEPTED_THETA_DISS = $self->{accepted_theta_diss};
    $ACCEPTED_SIGMA_DISS = $self->{accepted_sigma_diss};
    $ACCEPTED_OMEGA_DISS = $self->{accepted_omega_diss};
    $REPORT_ROGUE = $self->{report_rogue};
    $REPORT_MISSING = $self->{report_missing};
    return $self;
}

sub init {
    my $self = shift;
    $self->{keepdata} = 1;
    $self->{keeplinenums} = 1;
    print " Accepted dissimilarity index for Minimum Value of Objective Function: $self->{accepted_minobj_diss}\n";
    print "                                                                Theta: $self->{accepted_theta_diss}\n";
    print "                                                                Sigma: $self->{accepted_sigma_diss}\n";
    print "                                                                Omega: $self->{accepted_omega_diss}\n\n";
    print " Rogue elements/attributes are reported\n" if ($self->{report_rogue});
    print " Missing elements/attributes are reported\n" if ($self->{report_missing});
    return $self;
}

sub rogue_element {
    my $self = shift;
    my ($element, $properties) = @_;
    my ($element_name, $parent) = parent_and_name($element);
    my $info = {context => $parent,
                message => "Rogue element '$element_name' in element '$parent'."};
    $info->{rogue_element} = 1;
    
    #print $info->{message}."\n".Dumper($properties);
    if ($self->{keeplinenums}) {
        $info->{startline} = $properties->{TagStart};
        $info->{endline}   = $properties->{TagEnd};
    }
 
    if ($self->{keepdata}) {
        $info->{new_value} = $properties->{CData};
    }    
    return $info;
}

sub missing_element {
    my $self = shift;
    my ($element, $properties) = @_;
    my ($element_name, $parent) = parent_and_name($element);
    my $info = {context => $parent,
                message => "Child element '$element_name' missing from element '$parent'."};
    $info->{missing_element} = 1;
                 
    #print $info->{message}."\n".Dumper($properties);
    if ($self->{keeplinenums}) {
        $info->{startline} = $properties->{TagStart};
        $info->{endline}   = $properties->{TagEnd};
    }
    if ($self->{keepdata}) {
        $info->{old_value} = $properties->{CData};
    }
    return $info;
}


# compare XML elements in qualify.xml produced by NMQUAL
# "new" is our NONMEM installation, "old" is reference NONMEM installation
sub element_value {
    my ( $self, $element, $new_properties, $old_properties ) = @_;
    my ($element_name, $parent) = parent_and_name($element);
    my $info = {context => $element,
                element_name => $element_name};
    my $diss = 0; # dissimilarity from the reference

    # give a warning if 'our' THETA, OMEGA, SIGMA differ from 'reference' more than ACCEPTED_DIFF defined above
    #Example of Dumper output for THETA
    #print 'Element Name: '.$element_name.' Element:'.$element."\n";
    #print Dumper($new_properties);
    #$VAR1 = {
    #          'TagEnd' => 5312,
    #          'Attributes' => {
    #                            'nm:cname' => 'THETA2'
    #                          },
    #          'CData' => '5.593390687404538E-003',
    #          'TextChecksum' => 'wS1iABYa5rsHEQ20rcyXAg',
    #          'TagStart' => 5312,
    #          'NamespaceURI' => ''
    #        };
    if (defined $new_properties->{Attributes}->{cname}) {
	    if ($new_properties->{Attributes}->{cname}=~/THETA/ && 
                $old_properties->{CData} != 0 &&
                $new_properties->{CData}=~/[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?/ && 
                $old_properties->{CData}=~/[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?/) {
	        $diss = abs(($new_properties->{CData}/$old_properties->{CData}) - 1)*100;	
                if ($diss > $ACCEPTED_THETA_DISS) {
	            $info->{element_name} = $new_properties->{Attributes}->{cname}; 		
                    $info->{diss} = $diss;
                    $info->{diff} = (100*abs($new_properties->{CData}-$old_properties->{CData}))/abs(($new_properties->{CData}-$old_properties->{CData}+$old_properties->{CData})*0.5);
                    $info->{message} = "Warning: Theta dissimilarity exceeded $ACCEPTED_THETA_DISS in element '$info->{element_name}'";
                }
	    } elsif ($new_properties->{Attributes}->{cname}=~/SIGMA/ && 
                     $old_properties->{CData} != 0 &&
                     $new_properties->{CData}=~/[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?/ && 
                     $old_properties->{CData}=~/[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?/) {
	             $diss = abs(($new_properties->{CData}/$old_properties->{CData}) - 1)*100;	
                     if ($diss > $ACCEPTED_SIGMA_DISS) {
	                $info->{element_name} = $new_properties->{Attributes}->{cname}; 		
                        $info->{diss} = $diss;
                        $info->{diff} = (100*abs($new_properties->{CData}-$old_properties->{CData}))/abs(($new_properties->{CData}-$old_properties->{CData}+$old_properties->{CData})*0.5);
                        $info->{message} = "Warning: Sigma dissimilarity exceeded $ACCEPTED_SIGMA_DISS in element '$info->{element_name}'";
                     }
	    } elsif ($new_properties->{Attributes}->{cname}=~/OMEGA/ && 
                     $old_properties->{CData} != 0 &&
                     $new_properties->{CData}=~/[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?/ && 
                     $old_properties->{CData}=~/[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?/) {
	             $diss = abs(($new_properties->{CData}/$old_properties->{CData}) - 1)*100;	
                     if ($diss > $ACCEPTED_SIGMA_DISS) {
	                $info->{element_name} = $new_properties->{Attributes}->{cname}; 		
                        $info->{diss} = $diss;
                        $info->{diff} = (100*abs($new_properties->{CData}-$old_properties->{CData}))/abs(($new_properties->{CData}-$old_properties->{CData}+$old_properties->{CData})*0.5);
                        $info->{message} = "Warning: Omega dissimilarity excceded $ACCEPTED_OMEGA_DISS in element '$info->{element_name}'";
                     }
	    }
    }
    
    # issue special warning if our minimum value of objective function
    # differs from the reference more than ACCEPTED_MIN_DIFF 
    # Example of MINIMUM VALUE OF OBJECTIVE FUNCTION
    # <nm:final_objective_function_text>MINIMUM VALUE OF OBJECTIVE FUNCTION</nm:final_objective_function_text>
    # <nm:final_objective_function>104.561067310441</nm:final_objective_function>
    # $VAR1 = {
    #      'TagEnd' => 325,
    #      'Attributes' => {},
    #      'CData' => '8.00999999',
    #      'TextChecksum' => '37v/7gp1or9xSVnj2O6Dbw',
    #      'TagStart' => 325,
    #      'NamespaceURI' => 'http://namespaces.oreilly.com/xmlnut/address'
    #    };
   
    if ($element_name eq "final_objective_function") {
        #print Dumper($new_properties);
        $diss = abs(($new_properties->{CData}/$old_properties->{CData})- 1)*100 if $old_properties->{CData};
        if ($diss > $ACCEPTED_MINOBJ_DISS) {
	        $info->{element_name} = $element_name; 		
        	$info->{diss} = $diss;
                $info->{diff} = (100*abs($new_properties->{CData}-$old_properties->{CData}))/abs(($new_properties->{CData}-$old_properties->{CData}+$old_properties->{CData})*0.5);
        	$info->{message} = "Warning: 'Minimum Value of Objective Function' dissimilarity excceded $ACCEPTED_MINOBJ_DISS in $element";
	}
    }	

    if ($self->{keeplinenums}) {
        $info->{startline} = $new_properties->{TagStart}-13;
        $info->{endline}   = $new_properties->{TagEnd}-13;
    }
                  
    if ($self->{keepdata}) {
        $info->{old_value} = $old_properties->{CData};
        $info->{new_value} = $new_properties->{CData};
    }

    return $info;
}

sub rogue_attribute {
    my $self = shift;    
    my ($attr, $element, $properties) = @_;
    my ($element_name, $parent) = parent_and_name($element);
    my $info = {context  => $element,
                message  => "Rogue attribute '$attr' in element '$element_name'."};
    $info->{rogue_attr} = 1;
        
    if ($self->{keeplinenums}) {
        $info->{startline} = $properties->{TagStart};
        $info->{endline}   = $properties->{TagEnd};
    }

    if ($self->{keepdata}) {
        $info->{new_value} = $properties->{Attributes}->{$attr};
    }
    return $info;
}

sub missing_attribute {
    my $self = shift;
    my ($attr, $element, $new_properties, $old_properties) = @_;
    my ($element_name, $parent) = parent_and_name($element);
    my $info = {context  => $element,
                message  => "Attribute '$attr' missing from element '$element_name'."};
    $info->{missing_attr} = 1;
         
    if ($self->{keeplinenums}) {
        $info->{startline} = $new_properties->{TagStart};
        $info->{endline}   = $new_properties->{TagEnd};
    }

    if ($self->{keepdata}) {
        $info->{old_value} = $old_properties->{Attributes}->{$attr};
    }
    return $info;
}

sub attribute_value {
    my $self = shift;
    my ($attr, $element, $new_properties, $old_properties) = @_;
    my ($element_name, $parent) = parent_and_name($element);
    my $info = {context  => $element,
                message  => "Attribute '$attr' has different value in element '$element_name'."};
    $info->{attr_diff} = 1;
                  
    if ($self->{keeplinenums}) {
        $info->{startline} = $new_properties->{TagStart};
        $info->{endline}   = $new_properties->{TagEnd};
    }
        
    if ($self->{keepdata}) {
        $info->{old_value} = $old_properties->{Attributes}->{$attr};
        $info->{new_value} = $new_properties->{Attributes}->{$attr};
    }
    return $info;
}

sub namespace_uri {
    my $self = shift;
    my ($element, $new_properties, $old_properties) = @_;
    my ($element_name, $parent) = parent_and_name($element);
    my $info = {context  => $element,
                message  => "Element '$element_name' within different namespace."};
            
    if ($self->{keeplinenums}) {
        $info->{startline} = $new_properties->{TagStart};
        $info->{endline}   = $new_properties->{TagEnd};
    }
                            
    if ($self->{keepdata}) {
        $info->{old_value} = $old_properties->{NamspaceURI};
        $info->{new_value} = $new_properties->{NamspaceURI};
    }
    return $info;
}

sub parent_and_name {
    my $element = shift;
    my @steps = split('/', $element);   
    my $element_name = pop (@steps);
    my $parent = join '/', @steps;
    $element_name =~ s/\[\d+\]$//;
    return ($element_name, $parent);
}

1;

__END__

=head1 NAME

XML::SemanticDiff::NonmemHandler - NONMEM handler class for XML::SemanticDiff

=head1 SYNOPSIS

  use XML::SemanticDiff::NonmemHandler;
  my $h = XML::SemanticDiff::NonmemHandler->new();
  my $diff = XML::SemanticDiff->new(diffhandler => $h, keepdata => 1, keeplinenums => 1, ignorexpath => ["/log[1]/logged[1]/config[1]"]);
        
  foreach my $change ($diff->compare($file, $file2)) {
      print "$change->{message} in context $change->{context}\n";
  }

=head1 DESCRIPTION

This is the event handler for XML::SemanticDiff to compare NONMEM output produced by NMQUAL installation of NONMEM. It implements nothing useful apart from the parent class and should never be used directly.

Please run perldoc XML::SemanticDiff for more information.

=head1 IMPLEMENTED METHODS (FOR INTERNAL USE)

=head2 new
=head2 rogue_element
=head2 missing_element
=head2 element_value
=head2 rogue_attribute
=head2 missing_attribute
=head2 attribute_value
=head2 namespace_uri
=head2 parent_and_name

=head1 AUTHOR

Julia Ivashina julia.ivashina@gmail.com

=head1 COPYRIGHT
                  
Copyright (c) 2011 Julia Ivashina. All rights reserved. This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 SEE ALSO

XML::SemanticDiff::NonmemHandler

=cut


